home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / space.scm < prev    next >
Text File  |  1995-10-13  |  7KB  |  207 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; ,open architecture primitives assembler packages enumerated 
  6. ; ,open features sort locations display-conditions
  7.  
  8. (define length-procedures
  9.   (do ((i (- stob-count 1) (- i 1))
  10.        (l '() (cons (eval `(lap *length
  11.                                 (check-nargs= 1)
  12.                                 (pop)
  13.                                 (stored-object-length
  14.                                   ,(enumerand->name i stob))
  15.                 (push)
  16.                 (literal '2)
  17.                 (arithmetic-shift)
  18.                                 (return))
  19.                           (interaction-environment))
  20.                     l)))
  21.       ((< i 0) l)))
  22.  
  23. (define (space)
  24.   (collect)
  25.   (display "                     pure          impure        total") (newline)
  26.   (display "                  count  bytes  count  bytes  count  bytes")
  27.   (newline)
  28.   (let loop ((i 0)
  29.              (p-count-total 0)
  30.              (p-bytes-total 0)
  31.              (i-count-total 0)
  32.              (i-bytes-total 0))
  33.     (if (< i stob-count)
  34.         (begin
  35.           (collect)
  36.           (let ((xs (find-all-xs i))
  37.                 (length (list-ref length-procedures i)))
  38.             (let loop2 ((j (- (vector-length xs) 1))
  39.                         (p-count 0)
  40.                         (i-count 0)
  41.                         (p-bytes 0)
  42.                         (i-bytes 0))
  43.               (if (< j 0)
  44.                   (begin (report1 (enumerand->name i stob)
  45.                                   p-count p-bytes
  46.                                   i-count i-bytes)
  47.                          (loop (+ i 1)
  48.                                (+ p-count-total p-count)
  49.                                (+ p-bytes-total p-bytes)
  50.                                (+ i-count-total i-count)
  51.                                (+ i-bytes-total i-bytes)))
  52.                   (if (immutable? (vector-ref xs j))
  53.                       (loop2 (- j 1)
  54.                              (+ p-count 1)
  55.                              i-count
  56.                              (+ p-bytes (+ 4 (length (vector-ref xs j))))
  57.                              i-bytes)
  58.                       (loop2 (- j 1)
  59.                              p-count
  60.                              (+ i-count 1)
  61.                              p-bytes
  62.                              (+ i-bytes (+ 4 (length (vector-ref xs j))))))))))
  63.         (report1 'total
  64.                  p-count-total p-bytes-total
  65.                  i-count-total i-bytes-total))))
  66.  
  67. (define (report1 name p-count p-bytes i-count i-bytes)
  68.   (write-padded name 16)
  69.   (write-padded p-count 7)
  70.   (write-padded p-bytes 7)
  71.   (write-padded i-count 7)
  72.   (write-padded i-bytes 7)
  73.   (write-padded (+ p-count i-count) 7)
  74.   (write-padded (+ p-bytes i-bytes) 8)
  75.   (newline))
  76.  
  77. (define least-byte-type (enum stob string))
  78.  
  79.  
  80. (define (write-padded x pad)
  81.   (let ((s (if (symbol? x)
  82.                (symbol->string x)
  83.                (number->string x))))
  84.     (display (make-string (- pad (string-length s)) #\space))
  85.     (display s)))
  86.  
  87.  
  88. (define (record-space . pred-option)
  89.   (collect)
  90.   (let ((pred (if (null? pred-option) (lambda (x) #t) (car pred-option)))
  91.     (rs (find-all-xs (enum stob record)))
  92.         (a '()))
  93.     (do ((i (- (vector-length rs) 1) (- i 1)))
  94.         ((< i 0)
  95.          (for-each (lambda (z)
  96.                      (write-padded (cadr z) 7)
  97.                      (write-padded (* (caddr z) 4) 7)
  98.                      (display "  ")
  99.                      (write (car z))
  100.                      (newline))
  101.                    (sort-list a (lambda (z1 z2)
  102.                                   (> (caddr z1) (caddr z2))))))
  103.       (let* ((r (vector-ref rs i))
  104.              (probe (assq (record-ref r 0) a)))
  105.         (if (pred r)
  106.         (if probe
  107.         (begin (set-car! (cdr probe) (+ (cadr probe) 1))
  108.                (set-car! (cddr probe) (+ (caddr probe)
  109.                          (+ 1 (record-length r)))))
  110.         (set! a (cons (list (record-ref r 0) 1 (+ 1 (record-length r)))
  111.                   a))))))))
  112.                        
  113.  
  114. (define (vector-space . pred-option)
  115.   (collect)
  116.   (let ((pred (if (null? pred-option) (lambda (x) #t) (car pred-option)))
  117.     (vs (find-all-xs (enum stob vector))))
  118.     (let ((e-count 0)
  119.           (e-bytes 0)
  120.           (t-count 0)
  121.           (t-bytes 0)
  122.           (b-count 0)
  123.           (b-bytes 0)
  124.           (v-count 0)
  125.           (v-bytes 0)
  126.           (l-count 0)
  127.           (l-bytes 0)
  128.           (o-count 0)
  129.           (o-bytes 0))
  130.       (let loop ((i (- (vector-length vs) 1)))
  131.         (if (< i 0)
  132.             (let ((fz (lambda (k b what)
  133.                         (write-padded k 7)
  134.                         (write-padded b 7)
  135.                         (display what)
  136.                         (newline))))
  137.               (fz t-count t-bytes "  table buckets")
  138.               (fz e-count e-bytes "  table entries")
  139.               (fz b-count b-bytes "  bindings")
  140.               (fz v-count v-bytes "  environment info")
  141.               (fz l-count l-bytes "  lexical environments")
  142.               (fz o-count o-bytes "  other"))
  143.             (let* ((v (vector-ref vs i))
  144.                    (len (vector-length v))
  145.                    (bytes (* (+ len 1) 4)))
  146.               (cond ((not (pred v)))
  147.                     ((and (= len 3)
  148.                           (bucket? (vector-ref v 2)))
  149.                      (set! e-count (+ e-count 1))
  150.                      (set! e-bytes (+ e-bytes bytes)))
  151.                     ((and (= len 3)
  152.                           (location? (vector-ref v 1)))
  153.                      (set! b-count (+ b-count 1))
  154.                      (set! b-bytes (+ b-bytes bytes)))
  155.                     ((vector-every bucket? v)
  156.                      (set! t-count (+ t-count 1))
  157.                      (set! t-bytes (+ t-bytes bytes)))
  158.                     ((or (and (= len 4)
  159.                               (integer? (vector-ref v 0))
  160.                               (list? (vector-ref v 3)))
  161.                          (vector-every symbol? v))
  162.                      (set! v-count (+ v-count 1))
  163.                      (set! v-bytes (+ v-bytes bytes)))
  164.                     ((and (> len 1)
  165.                           (or (vector? (vector-ref v 0))
  166.                               (integer? (vector-ref v 0))))
  167.                      (set! l-count (+ l-count 1))
  168.                      (set! l-bytes (+ l-bytes bytes)))
  169.                     (else
  170.                      ;;(if (= (remainder i 197) 0)
  171.                      ;;    (begin (write v) (newline)))
  172.                      (set! o-count (+ o-count 1))
  173.                      (set! o-bytes (+ o-bytes bytes))))
  174.               (loop (- i 1))))))))
  175.  
  176.  
  177. (define (bucket? x)
  178.   (or (eq? x #f)
  179.       (vector? x)))
  180.  
  181. (define (vector-every pred v)
  182.   (let loop ((i (- (vector-length v) 1)))
  183.     (if (< i 0)
  184.         #t
  185.         (if (pred (vector-ref v i))
  186.             (loop (- i 1))
  187.             #f))))
  188.  
  189. (define (mutable? x) (not (immutable? x)))
  190.  
  191.  
  192. ; Print a random sampling of mutable pairs.
  193.  
  194. (define (pair-space)
  195.   (collect)
  196.   (let ((vs (find-all-xs (enum stob pair))))
  197.     (let loop ((i (- (vector-length vs) 1))
  198.            (j 0))
  199.       (if (>= i 0)
  200.       (let ((x (vector-ref vs i)))
  201.       (if (mutable? x)
  202.           (begin (if (= (remainder j 293) 0)
  203.              (begin (limited-write x (current-output-port) 4 4)
  204.                 (newline)))
  205.              (loop (- i 1) (+ j 1)))
  206.           (loop (- i 1) j)))))))
  207.